home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / twu1.zip / TWU1EQU.PAS < prev    next >
Pascal/Delphi Source File  |  1991-06-03  |  14KB  |  408 lines
  1. { -------------------------------------------------------------    }
  2. { This UNIT defines CONSTs, TYPEs, PROCEDUREs and FUNCTIONs of  }
  3. { general utility to the program.  It also enables a Heap Error }
  4. { Function which causes the Heap Manager to return NIL if any   }
  5. { Heap Allocation Request (NEW or GETMEM) finds insufficient    }
  6. { Heap Space to satisfy the request.  Two variables are defined }
  7. { which allow tracking of Heap utilization to be performed by a }
  8. { using program.  There is very little in this unit that is     }
  9. { specific to ".TPU" files per-se.                }
  10. { ------------------------------------------------------------- }
  11.  
  12. Unit TWU1EQU;
  13.  
  14. (*****************)
  15. (**) INTERFACE (**)    Uses Dos;
  16. (*****************)
  17.  
  18. Const
  19.     _FilNamLen = SizeOf(Dos.NameStr)+SizeOf(Dos.ExtStr)-2;
  20.         _FilDirLen = SizeOf(Dos.DirStr)-1+_FilNamLen;
  21.  
  22. Type
  23.     _FileSpec = String[_FilNamLen];    { Max Size of Name.Extension   }
  24.         _FileXpnd = String[_FilDirLen];    { Max Size of above plus Path  }
  25.       _StrByte  = String[2];        { String for Hex Byte Display  }
  26.     _StrWord  = String[4];          { String for Hex Word Display  }
  27.         _StrAddr  = String[5];        { String for Hex Addr Display  }
  28.     _DateStr  = String[10];        { String for Date/Time Display }
  29.  
  30.         _Paragraph= Array[0..15] of Byte;    { 8086 Paragraph Size  }
  31.     _Compare  = Function(VAR A,B):Boolean;  { QuickSort Calls This }
  32.  
  33.  
  34. Var     _HeapHighWaterMark,        { Max Heap Utilization Pointer }
  35.     _HeapOriginalMark : Pointer;    { Min Heap Utilization Pointer }
  36.  
  37. Function  PtrDelta(P,Q: Pointer): LongInt;    { Pointer Differential }
  38. Function  HexB(Arg:Byte): _StrByte;        { Byte to Hex String   }
  39. Function  HexW(Arg:Word): _StrWord;        { Word to Hex String   }
  40. Function  HexA(Arg:LongInt): _StrAddr;          { Addr to Hex String   }
  41. Function  FormatDate(Date: Word): _DateStr;     { Date Stamp to String }
  42. Function  FormatTime(Time: Word): _DateStr;     { Time Stamp to String }
  43.  
  44. Procedure QuickSort(V: Pointer;            { To Array of Records }
  45.             Cnt: Word;            { Record Count          }
  46.             Len: Word;            { Record Length       }
  47.          ALessB: _Compare);        { Compare Function    }
  48.  
  49. Procedure TrimString(VAR S: String);    { Removes Trailing Blanks }
  50.  
  51. function LoWord(A: LongInt): Word;
  52. inline(
  53.   $58/    { POP AX }
  54.   $5A);   { POP DX }
  55.  
  56. function HiWord(A: LongInt): Word;
  57. inline(
  58.   $5A/    { POP DX }
  59.   $58);   { POP AX }
  60.  
  61. function LoByte(A: Word): Byte;
  62. inline(
  63.   $5A/       { POP AX    }
  64.   $32/$E4);  { XOR AH,AH }
  65.  
  66. function HiByte(A: Word): Byte;
  67. inline(
  68.   $5A/       { POP AX    }
  69.   $8A/$C4/   { MOV AL,AH }
  70.   $32/$E4);  { XOR AH,AH }
  71.  
  72. Function PtrAdjust(A: Pointer; I: Word):Pointer;
  73. INLINE( $5A/            { POP DX    ;I        }
  74.     $58/            { POP AX    ;Ofs(A^)    }
  75.         $03/$C2/        { ADD AX,DX    ;Ofs(A^)+I    }
  76.         $5A);            { POP DX    ;Seg(A^)    }
  77.  
  78. (**********************)
  79. (**) IMPLEMENTATION (**)
  80. (**********************)
  81.  
  82.   { Procedure Below Removes Trailing Blanks from a String }    {.CP27}
  83.  
  84. Procedure TrimString(VAR S: String);
  85. { begin while    (Length(S)>0) AND (S[Length(S)]=' ') Do
  86.         Delete(S,Length(s),1) end }
  87. ASSEMBLER; {$S-}
  88. ASM                 
  89.         LES    DI,S            { Get String Pointer    }
  90.         MOV    CX,ES            { Get Segment Value    }
  91.         CMP    CX,DI            { Check for Nil Pointer    }
  92.         JNZ    @RUN            { Don't Match-Not Nil    }
  93.         JCXZ    @SKIP            { Nil if Selector zero    }
  94.   @RUN:
  95.     XOR    CX,CX            { Clean-Up CX        }
  96.         MOV    CL,ES:[DI]        { Fetch String Length    }
  97.         JCXZ    @SKIP            { Exit if Null String    }
  98.         STD                { Set RTL Direction    }
  99.         MOV    DX,DI            { Save String Offset    }
  100.         MOV    AL,' '            { Load Blank Comparand    }
  101.         ADD    DI,CX            { Point to String End    }
  102.    REPZ SCASB                { Scan for Non-Blank    }
  103.       JZ    @NONE            { NONE FOUND        }
  104.         INC    CX            { Repair CX        }
  105.   @NONE:
  106.       MOV    DI,DX            { Point to String    }
  107.         MOV    ES:[DI],CL        { Save New Length Byte    }
  108.   @SKIP:
  109. END;        {$S+}
  110.  
  111.   { Function Below Computes the SIGNED Difference between the }    {.CP36}
  112.   { EFFECTIVE Values of two pointers, P and Q.  The result is }
  113.   { negative if P^ < Q^, non-negative otherwise.          }
  114.  
  115. Function PtrDelta(P, Q: Pointer): LongInt;    { Pointer Differential }
  116. (* --------------------- Equivalent Pascal Code
  117. Var Lp, Lq : LongInt;
  118. Begin
  119.    Lp := LongInt(Seg(P^)) SHL 4 + Ofs(P^);    { Convert P to LongInt }
  120.    Lq := LongInt(Seg(Q^)) SHL 4 + Ofs(Q^);    { Convert Q to LongInt }
  121.    PtrDelta := Lp - Lq;                { Return Difference    }
  122. *)
  123. ASSEMBLER; {$S-}
  124. ASM
  125.     MOV    CL,04h            { Set Shift Amount         }
  126.         XOR    DH,DH            { Zero DH            }
  127.         LES    DI,[DWORD PTR P]    { Fetch P to ES:DI        }
  128.         MOV    AX,ES            { AX = Seg(P^)            }
  129.         MOV    DL,AH            { Copy Hi Byte to DL        }
  130.         SHR    DL,CL            { Align Hi Bits in DL        }
  131.         SHL    AX,CL            { Align Lo Bits in AX        }
  132.         ADD    DI,AX            { Lo Order Sum in DI        }
  133.         ADC    DX,0            { Hi Order Sum in DX        }
  134.                         { DX:DI = LongInt(P^)        }
  135.         XOR    BH,BH
  136.         LES    SI,[DWORD PTR Q]    { Fetch Q to ES:SI        }
  137.         MOV    AX,ES            { AX = Seg(Q^)            }
  138.         MOV    BL,AH            { Copy Hi Byte to BL        }
  139.         SHR    BL,CL            { Align Hi Bits in BL        }
  140.         SHL    AX,CL            { Align Lo Bits in AX        }
  141.         ADD    SI,AX            { Lo Order Sum in SI        }
  142.         ADC    BX,0            { Hi Order Sum in BX        }
  143.         MOV    AX,DI            { AX = LO(LongInt(P^))        }
  144.         SUB    AX,SI            { AX = Lo Difference        }
  145.         SBB    DX,BX            { DX = Hi Difference        }
  146. End; {PtrDelta}      {$S+}
  147.  
  148.   { Function Below Formats Directory Time-Stamp for Display }    {.CP44}
  149.  
  150. Function FormatTime(Time : Word): _DateStr;
  151. VAR Ww: _DateStr;
  152. BEGIN
  153.      ASM    { Emit Tight Fast Code  }
  154.         CLD                 { Clear Direction Flag    }
  155.          MOV    AX,SS            { Load String Segment    }
  156.         MOV    ES,AX
  157.     LEA    DI,[BYTE PTR Ww]    { Load String Offset    }
  158.         MOV    AL,8            { String Length = 8    }
  159.         STOSB
  160.     MOV    DX,'00'            { Load ASCII Zero Zones    }
  161.  
  162.     MOV    AX,Time            { Fetch Time        }
  163.     MOV    CL,11            { Set Shift Bit Count    }
  164.     SHR    AX,CL            { Align Hours        }
  165.         CALL    @Emit            { Encode and Store it    }
  166.     MOV    AL,':'            { Insert : after Hours    }
  167.         STOSB
  168.  
  169.     MOV    AX,Time            { Fetch Time        }
  170.     MOV    CL,5            { Set Shift Bit Count    }
  171.     SHR    AX,CL            { Align Minutes        }
  172.     AND    AL,3Fh            { Extract Minutes    }
  173.         CALL    @Emit            { Encode and Store it    }
  174.     MOV    AL,':'            { Insert : after Minutes}
  175.         STOSB
  176.  
  177.     MOV    AL,[Byte Ptr Time]    { Fetch Low Time Byte    }
  178.     AND    AL,1Fh            { Extract Seconds / 2    }
  179.     SHL    AL,1            { Convert to Seconds    }
  180.     CALL    @Emit            { Encode and Store it    }
  181.         JMP    @Exit            { Skip Around Proc    }
  182.      @Emit:
  183.     AAM                { Convert AL to Decimal    }
  184.     XCHG    AH,AL            { Swap Resulting Digits }
  185.     OR    AX,DX            { Add ASCII Zones    }
  186.     STOSW                { Store String Result    }
  187.         RETN                { Return to caller    }
  188.      @Exit:
  189.      End;
  190.         FormatTime := Ww;
  191. END; {FormatTime}
  192.  
  193.   { Function Below Formats Directory Date-Stamp for Display }    {.CP49}
  194.  
  195. Function FormatDate(Date : Word): _DateStr;
  196. VAR Ww: _DateStr;
  197. BEGIN
  198.      ASM    { Emit Tight Fast Code  }
  199.         CLD                 { Clear Direction Flag    }
  200.          MOV    AX,SS            { Load String Segment    }
  201.         MOV    ES,AX
  202.     LEA    DI,[BYTE PTR Ww]    { Load String Offset    }
  203.         MOV    AL,10            { String Length = 10    }
  204.         STOSB
  205.     MOV    DX,'00'            { Load ASCII Zero Zones    }
  206.  
  207.     MOV    AX,Date            { Fetch Date        }
  208.     MOV    CL,5            { Set Shift Bit Count    }
  209.     SHR    AX,CL            { Align Month        }
  210.     AND    AL,0Fh          { Extract Month        }
  211.         CALL    @Emit            { Encode and Store it    }
  212.     MOV    AL,'/'            { Insert / after Month    }
  213.         STOSB
  214.  
  215.     MOV    AL,[Byte Ptr Date]    { Fetch Date        }
  216.     AND    AL,1Fh            { Extract Day of Month    }
  217.         CALL    @Emit            { Encode and Store it    }
  218.     MOV    AL,'/'            { Insert / after Day    }
  219.         STOSB
  220.  
  221.     MOV    CL,9            { Set Shift Bit Count    }
  222.     MOV    AX,Date            { Fetch Date        }
  223.     SHR    AX,CL            { Align Year Bits    }
  224.     ADD    AX,1980            { Add 1980        }
  225.     MOV    BL,100          { Set up Divisor    }
  226.     DIV    BL            { AH= Year, AL= Century    }
  227.     MOV    BL,AH            { Save Year Byte    }
  228.         CALL    @Emit            { Encode and Store Cent }
  229.     MOV    AX,BX            { Fetch Year Byte    }
  230.     CALL    @Emit            { Encode and Store Year    }
  231.         JMP    @Exit            { Skip Around Proc    }
  232.      @Emit:
  233.     AAM                { Convert AL to Decimal    }
  234.     XCHG    AH,AL            { Swap Resulting Digits }
  235.     OR    AX,DX            { Add ASCII Zones    }
  236.     STOSW                { Store String Result    }
  237.         RETN                { Return to caller    }
  238.      @Exit:
  239.      End;
  240.         FormatDate := Ww;
  241. END; {FormatDate}
  242.  
  243.   { Function Below Converts a byte to Printable Hex }        {.CP22}
  244. (*
  245.     FUNCTION HexB(Arg:byte): _StrByte;
  246.     CONST HexTab : ARRAY[0..15] OF Char = '0123456789ABCDEF';
  247.     BEGIN HexB := HexTab[Arg SHR 4] + HexTab[Arg AND $F] END;
  248. *)
  249. {$S-} FUNCTION HexB(Arg:byte): _StrByte; ASSEMBLER;
  250. CONST HexTab : ARRAY[0..15] OF Char = '0123456789ABCDEF';
  251. ASM
  252.     LES    DI,@RESULT    { Point to Function Result  }
  253.     MOV    AX,2        { Get Result String Length  }
  254.     STOSB            { Store in Result String    }
  255.     LEA    BX,HexTab    { Point to Translate Table  }
  256.     MOV    AL,Arg        { Fetch Argument Byte        }
  257.     MOV    CL,4        { Set Shift Counter        }
  258.     SHL    AX,CL        { Put Hi Nibble in AH        }
  259.     SHR    AL,CL        { Put Lo Nibble    in AL        }
  260.     XLAT            { Translate Lo Nibble        }
  261.     XCHG    AH,AL        { Swap Hi and Lo Nibbles    }
  262.     XLAT            { Translate Hi Nibble        }
  263.     STOSW            { Emit Translated Nibbles   }
  264. END;    {HexB}{$S+}
  265.  
  266.   { Function Below Converts a Word to Printable Hex }        {.CP04}
  267.  
  268. FUNCTION HexW(Arg:Word): _StrWord;
  269. BEGIN HexW := HexB(HI(Arg)) + HexB(LO(Arg)) END;
  270.  
  271.   { Function Below Converts a Addr to Printable Hex }        {.CP08}
  272.  
  273. FUNCTION HexA(Arg:LongInt): _StrAddr;
  274. Var PreFix : _StrByte;
  275. BEGIN
  276.    PreFix := HexB(LoByte(HiWord(Arg)));
  277.    HexA   := PreFix[2] + HexW(LoWord(Arg))
  278. END;
  279.  
  280.  
  281.   { Heap Error Function Returns NIL if Allocation Fails }    {.CP11}
  282.  
  283. Function HeapErrorProc(Arg : Word): Integer; FAR;
  284. Begin
  285.     If Arg = 0 Then        { Heap Pointer Being Raised   }
  286.  
  287.         If PtrDelta(System.HeapPtr,_HeapHighWaterMark) > 0
  288.     Then _HeapHighWaterMark := System.HeapPtr;
  289.  
  290.         HeapErrorProc := 1;     { Allow NIL Return by HeapMgr }
  291. End;   {HeapErrorProc}
  292.  
  293. { --------------------------------------------------------------- }
  294. { QuickSort Algorithm by C.A.R. Hoare.  Non-Recursive adaptation  }
  295. { from "ALGORITHMS + DATA STRUCTURES = PROGRAMS" by Niklaus Wirth }
  296. { Prentice-Hall, 1976.    Generalized for untyped arguments.      }
  297. { --------------------------------------------------------------- }
  298.  
  299. Procedure QuickSort(V: Pointer;        { To Array of Records }
  300.             Cnt: Word;        { Record Count          }
  301.             Len: Word;        { Record Length       }
  302.          ALessB: _Compare);    { Compare Function    }
  303.  
  304. Type    SortRec  = Record Lt, Rt: Integer End;
  305.     SortStak = Array[0..1] of SortRec;
  306.  
  307. Var StkT, StkM, Ki, Kj, M: Word; Rt, Lt, I, J: Integer;
  308.     Ps: ^SortStak; Pw, Px: Pointer;
  309.  
  310.     Procedure Push(Left, Right: Integer);
  311.     Begin Ps^[StkT].Lt := Left; Ps^[StkT].Rt := Right; Inc(StkT); End;
  312.  
  313.     Procedure Pop(VAR Left, Right: Integer);
  314.     Begin Dec(StkT); Left := Ps^[StkT].Lt; Right := Ps^[StkT].Rt; End;
  315.  
  316. Begin {QSort}
  317.    If (Cnt > 1) AND (V <> Nil) Then
  318.    Begin
  319.       StkT := Cnt - 1;                { Record Count - 1 }
  320.       Lt := 1;                                  { Safety Valve       }
  321.  
  322.       { We need a stack of Log2(n-1) entries plus 1 spare for safety }
  323.  
  324.       Repeat StkT := StkT SHR 1; Inc(Lt); Until StkT = 0; { 1+Log2(n-1) }
  325.  
  326.       StkM := Lt * SizeOf(SortRec) + Len + Len;    { Stack Size + 2 records }
  327.  
  328.       GetMem(Ps,StkM);            { Allocate Memory    }
  329.  
  330.       If Ps = Nil Then RunError(215);    { Catastrophic Error }
  331.  
  332.       Pw := @Ps^[Lt];            { Swap Area Pointer  }
  333.       Px := Ptr(Seg(Pw^),Ofs(Pw^)+Len);    { Hold Area Pointer  }
  334.  
  335.       Lt := 0; Rt := Cnt - 1;        { Initial Partition  }
  336.       Push(Lt,Rt);            { Push Entire Table  }
  337.  
  338.       WHILE StkT > 0 Do Begin        { QuickSort Main Loop }
  339.          Pop(Lt,Rt);            { Get Next Partition  }
  340.          Repeat
  341.             I := Lt; J := Rt;        { Set Work Pointers }
  342.  
  343.             { Save Record at Partition Mid-Point in Hold Area }
  344.  
  345.             M := (LongInt(Lt) + Rt) DIV 2;
  346.             Move(Ptr(Seg(V^),Ofs(V^)+ M * Len)^,Px^,Len);
  347.  
  348.             { Get Useful Offsets to speed loops }
  349.  
  350.             Ki := I * Len + Ofs(V^); Kj := J * Len + Ofs(V^);
  351.  
  352.             Repeat
  353.  
  354.                { Find Left-Most Entry >= Mid-Point Entry }
  355.  
  356.            While ALessB(Ptr(Seg(V^),Ki)^,Px^) Do
  357.                  Begin Inc(Ki,Len); Inc(I) End;
  358.  
  359.                { Find Right-Most Entry <= Mid-Point Entry }
  360.  
  361.            While ALessB(Px^,Ptr(Seg(V^),Kj)^) Do
  362.                  Begin Dec(Kj,Len); Dec(J) End;
  363.  
  364.                { If I > J, the partition has been exhausted }
  365.  
  366.                If I <= J Then
  367.                Begin
  368.  
  369.                   If I < J Then  { we have two records to exchange }
  370.                   Begin
  371.                         Move(Ptr(Seg(V^),Ki)^,Pw^,Len);
  372.                         Move(Ptr(Seg(V^),Kj)^,Ptr(Seg(V^),Ki)^,Len);
  373.                         Move(Pw^,Ptr(Seg(V^),Kj)^,Len);
  374.                   End;
  375.  
  376.                   Inc(I); Dec(J); Inc(Ki,Len); Dec(Kj,Len);
  377.                End;    { If I <= J }
  378.             Until I > J;        { Until All Swaps Done }
  379.  
  380.             { We now have two partitions.  At left are all records }
  381.             { < X, and at right are all records > X.  The larger   }
  382.             { partition is stacked and we re-partition the residue }
  383.             { until time to pop a deferred partition.              }
  384.  
  385.             If (J-Lt) < (Rt-I)
  386.         Then        { Right-Most Partition is Larger }
  387.         Begin
  388.            If I < Rt Then Push(I,Rt);    { Stack Right Side }
  389.            Rt := J;                { Resume with Left }
  390.         End
  391.         Else        {  Left-Most Partition is Larger }
  392.         Begin
  393.            If Lt < J Then Push(Lt,J);    { Stack Left Side   }
  394.            Lt := I;                { Resume with Right }
  395.         End;
  396.  
  397.          Until Lt >= Rt;        { QuickSort is now Complete }
  398.       END;
  399.       FreeMem(Ps,StkM);            { Free Stack and Work Areas }
  400.    End;
  401. End; {QSort}
  402.  
  403. Begin   {Unit Initialization}
  404.     System.HeapError   := @HeapErrorProc;
  405.         _HeapHighWaterMark := System.HeapPtr;
  406.         _HeapOriginalMark  := System.HeapOrg;
  407. End.
  408.